home *** CD-ROM | disk | FTP | other *** search
/ Collection of Tools & Utilities / Collection of Tools and Utilities.iso / batchut / setenv13.zip / SETENV.PAS < prev    next >
Pascal/Delphi Source File  |  1989-09-28  |  7KB  |  267 lines
  1. unit setenv;
  2. interface
  3. type  s24 = string;
  4. Function SetTheEnv (symbol, val : s24) : boolean;
  5.  
  6. implementation
  7. uses asciiz;
  8. const
  9.    arena_size = 16;
  10.    NORMAL_ATYPE = #$4D;
  11.    LAST_ATYPE   = #$5A;
  12.    COMSPEC : string[8] = 'COMSPEC=';
  13.  
  14. type
  15.     PSP = record
  16.     fill1              : array [1..10] of char;
  17.         PrevTermHandlerPtr : ^integer;
  18.     PrevCtrlCptr       : ^integer;
  19.     PrevCritErrPtr     : ^integer;
  20.     fill2              : array [1..22] of char;
  21.     EnvirSeg           : word;
  22.         end;
  23.  
  24.     Arena = record
  25.     ArenaType     : char;
  26.     PspSegment    : word;
  27.     NumOfSegments : word;
  28.         fill3         : array [1..11] of char;
  29.         ArenaData     : ca;
  30.         end;
  31.  
  32.      str4 = string[4];
  33.  
  34. var
  35.     ap    : ^arena;
  36.  
  37. {$ifdef Debug}
  38. Function HexStr (n:word):str4;
  39.    const ha:array[0..15] of char=('0','1','2','3','4','5','6','7','8','9','a','b','c','d','e','f');
  40.    var str : str4;
  41.    begin
  42.    str[0]:=chr(4);
  43.    str[1]:=ha[hi(n) shr 4];
  44.    str[2]:=ha[hi(n) and $F];
  45.    str[3]:=ha[(n shr 4) and $F];
  46.    str[4]:=ha[n and $F];
  47.    HexStr := str;
  48.    end;
  49. {$endif}
  50.  
  51.  
  52. Function GetNextArena (var ap:arena) : pointer;
  53.    var tp : pointer;
  54.    begin
  55.    tp := Ptr( Seg(ap)+1+ap.NumOfSegments, 0);
  56.    GetNextArena := tp;
  57.    end {GetNextArena};
  58.  
  59.  
  60. Function IsValidArena (var ar:arena) : boolean;
  61. var ap1 : ^arena;
  62.    begin
  63.    IsValidArena := false;
  64.    if ar.ArenaType <> NORMAL_ATYPE   then  Exit;
  65.    ap1 := GetNextArena (ar);
  66.    if ap1^.ArenaType <> NORMAL_ATYPE then  Exit;
  67.  
  68.    ap1 := GetNextArena (ap1^);
  69.    if (ap1^.ArenaType <> NORMAL_ATYPE) and
  70.       (ap1^.ArenaType <> LAST_ATYPE)        then  Exit;
  71.    IsValidArena:=true;
  72.    end {IsValidArena};
  73.  
  74.  
  75. Function GetFirstArena : pointer;
  76. { return pointer to the first arena.
  77.   scan memory for a 0x4D on a segment start,
  78.   see if this points to another two levels of arena. }
  79. var
  80.    ap, ap1  : ^arena;
  81.    segment  : word;
  82.  
  83.    begin
  84.         for segment:=60 to Cseg do
  85.             begin
  86.             ap := ptr(segment, 0);
  87.             if IsValidArena (ap^)  then
  88.                begin  GetFirstArena := ap;  Exit;  end;
  89.             end;
  90.     GetFirstArena := nil;
  91. end {GetFirstArena};
  92.  
  93.  
  94. Function IsValidEnv (var ad:ca; NumSegs:integer):boolean;
  95. var
  96.    COMSPECa : ca;
  97.    adp      : cap;
  98.    BaseAD   : word;
  99.  
  100.    begin
  101.    BaseAD := ofs (ad);
  102.    adp    := @ad;
  103.    PtoA (COMSPEC, COMSPECa);
  104.    while ( adp^[0] <> #0 ) and
  105.          ( (ofs(adp^)-BaseAD) shr 4 < NumSegs ) do
  106.         begin
  107.         if (strnicmp(adp^, COMSPECa, 8) = 0) then
  108.             begin  IsValidEnv:=true;  Exit;  end;
  109.         adp := @adp^[strlen(adp^) + 1];
  110.         end {while};
  111.    IsValidEnv := false;
  112. end {IsValidEnv};
  113.  
  114.  
  115. Function GetArenaOfEnvironment : pointer;
  116. {  First get segment of COMMAND.COM from segment of previous critical err code.
  117.    then go to this COMMAND.COM, and go get its ENV block,
  118.    check that it is an ENV block }
  119.  
  120. Label L1, L2;
  121. var
  122.    ap       : ^arena;
  123.    Mypsp    : ^psp;
  124.    CCpsp    : ^psp;
  125.    CCseg, i : word;
  126.    EnvSeg   : word;
  127.    ad       : cap;
  128.  
  129.    begin
  130.    GetArenaOfEnvironment := NIL;
  131.  
  132.    { set Mypspp to psp of this program }
  133.    Mypsp := Ptr (PrefixSeg, 0);
  134.  
  135.    { set CCpsp to psp of COMMAND.COM }
  136.    CCseg := Seg (Mypsp^.PrevCritErrPtr^);
  137.    i := CCseg - 32;   if i<60 then i:=60;
  138.  
  139.    while CCseg > i do
  140.          begin
  141.          ap := Ptr (CCseg, 0);
  142.          if IsValidArena (ap^) then  goto L1;
  143.          dec (CCseg);
  144.          end;
  145.     exit;   {error}
  146.  
  147. L1: inc (CCseg);
  148.     CCpsp := Ptr (CCseg, 0);
  149.  
  150.    {$ifdef Debug}
  151.       writeln ('prog psp=', HexStr(seg(Mypsp^)),
  152.                ' prog crit_err_seg=', HexStr(CCseg) );
  153.    {$endif}
  154.  
  155.    {first see if the env seg in command.com points at a good env block?}
  156.    EnvSeg := CCpsp^.EnvirSeg;
  157.    ap := Ptr (EnvSeg-1, 0);
  158.  
  159.    {$ifdef Debug}
  160.       writeln ('Env ', HexStr(seg(ap^)),
  161.                     ',  psp in env=', HexStr(ap^.PspSegment));
  162.    {$endif}
  163.  
  164.    { if a valid arena, then search the entire arena for validity,
  165.      if not a valid arena, then maybe it is one of these fabricated
  166.      guys that shells like "4DOS" set up, search the first 128 bytes
  167.      only }
  168.  
  169.    i := ap^.NumOfSegments-1;
  170.  
  171.    if not IsValidArena(ap^) then
  172.       i := 9
  173.    else
  174.       if  ap^.PspSegment <> CCseg  then  goto L2;
  175.  
  176.    if IsValidEnv(ap^.ArenaData, i) then
  177.       begin
  178.       GetArenaOfEnvironment := ap;
  179.       {$ifdef Debug} writeln('env found');  {$endif}
  180.       Exit;
  181.       end;
  182.  
  183.    {command.com did not have a good env segment, lets search all MCB's }
  184. L2:
  185.    ap := GetFirstArena;
  186.    if ap=NIL then Exit;
  187.    while (ap^.ArenaType <> LAST_ATYPE) do
  188.         begin
  189.         {$ifdef Debug} Writeln ('arena ', HexStr(seg(ap^)));  {$endif}
  190.         if (ap^.PspSegment=CCseg) and
  191.             IsValidEnv(ap^.ArenaData, ap^.NumOfSegments-1) then
  192.            begin
  193.            GetArenaOfEnvironment := ap;
  194.            {$ifdef Debug} writeln('env found'); {$endif}
  195.            Exit;
  196.            end;
  197.         ap := GetNextArena (ap^);
  198.         end;
  199.  
  200.    end {GetArenaOfEnvironment};
  201.  
  202. {*****************************************************************************}
  203.  
  204. Function SetTheEnv (symbol, val : s24) : boolean;
  205. var
  206.     TotalEnvSize,
  207.     NeededSize,
  208.     strlength     : integer;
  209.     sp, op, envir : cap;
  210.     SymbolLen     : integer;
  211.     SymbolA, ValA : ca;
  212.     Found         : boolean;
  213.     ap            : ^arena;
  214.  
  215.     begin
  216.     NeededSize := 0;
  217.     Found      := false;
  218.     SetTheEnv  := false;
  219.  
  220.     PtoA  (Symbol, SymbolA);
  221.     PtoA  (Val, ValA);
  222.     strupr(symbolA);
  223.     SymbolLen := strlen (symbolA);
  224.     SymbolA [SymbolLen]   := '=';
  225.     SymbolA [SymbolLen+1] := #0;
  226.  
  227.     { first, can the COMMAND.COM envir block be found ? }
  228.     ap := GetArenaOfEnvironment;
  229.     if ( ap = NIL) then  exit;
  230.  
  231.  
  232.     { search to end of the envir block, get sizes }
  233.     TotalEnvSize := 16 * ap^.NumOfSegments;
  234.     envir := @ap^.ArenaData;
  235.     op    := envir;
  236.     sp    := envir;
  237.  
  238.     while sp^[0] <> #0 do
  239.         begin
  240.     strlength := strlen(sp^)+1;
  241.     if ( strnicmp(sp^, symbolA, SymbolLen+1) = 0 )  then
  242.          found := true
  243.     else
  244.              begin
  245.              NeededSize := NeededSize + strlength;
  246.              if found then  strcpy(op^  , sp^);
  247.              op := @op^[strlength];
  248.          end;
  249.     sp := @sp^[strlength];
  250.         end;
  251.     op^[0] := #0;
  252.  
  253.     if (strlen(valA) > 0) then
  254.         begin
  255.     NeededSize := NeededSize + 3 + SymbolLen + strlen(valA);
  256.  
  257.     if (NeededSize > TotalEnvSize) then
  258.         Exit;    {could mess with environment expansion here}
  259.  
  260.     strcpy(op^, symbolA);  strcat(op^, valA);
  261.     op := @op^[strlen(op^)+1];
  262.         end;
  263.     op^[0] := #0;
  264.     SetTheEnv := true;
  265.   end {SetTheEnv};
  266.  
  267. end.